home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / PARSER.Y < prev    next >
Text File  |  1991-11-20  |  22KB  |  630 lines
  1. /* --------------------------------------------------------------------------
  2.  * parser.y:    Copyright (c) Mark P Jones 1991.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.21  November 1991
  5.  *
  6.  *        Last updated 11/11/91 mpj
  7.  *
  8.  * Gofer parser (included as part of input.c)
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. %{
  12. #ifndef lint
  13. #define lint
  14. #endif
  15. #define typeDefn(line,lhs,rhs)     newTypeDefn(intOf(line),lhs,rhs,FALSE)
  16. #define dataDefn(line,lhs,rhs)     newTypeDefn(intOf(line),lhs,rhs,TRUE)
  17. #define sigdecl(l,vs,t)         ap(SIGDECL,triple(l,vs,t))
  18. #define grded(gs)         ap(GUARDED,gs)
  19. #define letrec(bs,e)         (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
  20. #define yyerror(s)         /* errors handled elsewhere */
  21. #define YYSTYPE             Cell
  22.  
  23. static Cell   local gcShadow     Args((Int,Cell));
  24. static Void   local syntaxError  Args((String));
  25. static String local unexpected   Args((Void));
  26. static Cell   local checkPrec    Args((Cell));
  27. static Void   local fixDefn      Args((Syntax,Cell,Cell,List));
  28. static Void   local setSyntax    Args((Int,Syntax,Cell));
  29. static Cell   local buildTuple   Args((List));
  30. static Cell   local checkClass   Args((Cell));
  31. static List   local checkContext Args((List));
  32. static Cell   local tidyInfix    Args((Cell));
  33.  
  34. /* For the purposes of reasonably portable garbage collection, it is
  35.  * necessary to simulate the YACC stack on the Gofer stack to keep
  36.  * track of all intermediate constructs.  The lexical analyser
  37.  * pushes a token onto the stack for each token that is found, with
  38.  * these elements being removed as reduce actions are performed,
  39.  * taking account of look-ahead tokens as described by gcShadow()
  40.  * below.
  41.  *
  42.  * Of the non-terminals used below, only start and topdecl do not leave
  43.  * any values of the Gofer stack.  The same is true for the terminals
  44.  * EVALEX and MODULE.  At the end of a successful parse, there should only
  45.  * be one element left on the stack, containing the result of the parse.
  46.  */
  47.  
  48. #define gc0(e)             gcShadow(0,e)
  49. #define gc1(e)             gcShadow(1,e)
  50. #define gc2(e)             gcShadow(2,e)
  51. #define gc3(e)             gcShadow(3,e)
  52. #define gc4(e)             gcShadow(4,e)
  53. #define gc5(e)             gcShadow(5,e)
  54. #define gc6(e)             gcShadow(6,e)
  55.  
  56. %}
  57.  
  58. %token EVALEX    MODULE     SCRIPT
  59. %token '='       COCO       INFIXL     INFIXR     INFIX      FUNARROW
  60. %token '-'       ','        '@'        '('        ')'        '|'
  61. %token ';'       UPTO       '['        ']'        CASEXP     OF
  62. %token IF        THEN       ELSE       WHERE      TYPE       DATA
  63. %token FROM      '\\'       '~'        LET        IN         '`'
  64. %token VAROP     VARID      NUMLIT     CHARLIT    STRINGLIT  REPEAT
  65. %token CONOP     CONID
  66. %token TCLASS    IMPLIES    TINSTANCE
  67. %token PRIMITIVE
  68.  
  69. %%
  70. /*- Top level script/module structure -------------------------------------*/
  71.  
  72. start      : EVALEX exp            {inputExpr = $2;        sp-=1;}
  73.       | EVALEX exp wherePart    {inputExpr = letrec($3,$2); sp-=2;}
  74.       | MODULE '{' topdecls close    {valDefns  = $3;        sp-=3;}
  75.       | error            {syntaxError("input");}
  76.       ;
  77. topdecls  : topdecls ';' topdecl    {$$ = gc2($1);}
  78.       | topdecls ';' decl        {$$ = gc3(cons($3,$1));}
  79.       | topdecl            {$$ = gc0(NIL);}
  80.       | decl            {$$ = gc1(cons($1,NIL));}
  81.       | error            {syntaxError("definition");}
  82.       ;
  83.  
  84. /*- Type declarations: ----------------------------------------------------*/
  85.  
  86. topdecl      : TYPE typeLhs '=' type    {typeDefn($3,$2,$4);      sp-=4;}
  87.       | DATA typeLhs '=' constrs    {dataDefn($3,$2,rev($4)); sp-=4;}
  88.       ;
  89. typeLhs      : typeLhs VARID        {$$ = gc2(ap($1,$2));}
  90.       | CONID            {$$ = $1;}
  91.       | error            {syntaxError("type defn lhs");}
  92.       ;
  93. constrs      : constrs '|' constr        {$$ = gc3(cons($3,$1));}
  94.       | constr            {$$ = gc1(cons($1,NIL));}
  95.       ;
  96. constr      : type CONOP type        {$$ = gc3(ap(ap($2,$1),$3));}
  97.       | typeApp1            {$$ = $1;}
  98.       | CONID            {$$ = $1;}
  99.       ;
  100.  
  101. /*- Type expressions: -----------------------------------------------------*/
  102. /*  Parser is not sufficently powerful to distinguish between a predicate
  103.  *  such as "Dual a b" and a type "Sum a b", or between a tuple type and
  104.  *  a context (e.g. (Alpha a, Beta b) is a tuple or context?).  For this
  105.  *  reason, individual predicates and contexts are parsed as types, with
  106.  *  additional code to check for well formed context/classes.
  107.  */
  108.  
  109. sigType      : context IMPLIES type    {$$ = gc3(ap(QUAL,pair($1,$3)));}
  110.       | type            {$$ = $1;}
  111.       ;
  112. context      : type            {$$ = gc1(checkContext($1));}
  113.       ;
  114. type      : ctype            {$$ = $1;}
  115.       | ctype FUNARROW type        {$$ = gc3(ap(ap(ARROW,$1),$3));}
  116.       | error            {syntaxError("type expression");}
  117.       ;
  118. ctype      : typeApp1            {$$ = $1;}
  119.       | atype            {$$ = $1;}
  120.       ;
  121. atype      : VARID            {$$ = $1;}
  122.       | CONID            {$$ = $1;}
  123.       | '(' ')'            {$$ = gc2(UNIT);}
  124.       | '(' type ')'        {$$ = gc3($2);}
  125.       | '(' typeTuple ')'        {$$ = gc3(buildTuple($2));}
  126.       | '[' type ']'        {$$ = gc3(ap(LIST,$2));};
  127.       ;
  128. typeApp1  : typeApp1 atype        {$$ = gc2(ap($1,$2));}
  129.       | CONID atype            {$$ = gc2(ap($1,$2));}
  130.       ;
  131. typeTuple : typeTuple ',' type        {$$ = gc3(cons($3,$1));}
  132.       | type ',' type        {$$ = gc3(cons($3,cons($1,NIL)));}
  133.       ;
  134.  
  135. /*- Fixity declarations: --------------------------------------------------*/
  136.  
  137. topdecl      : INFIXL optdigit ops        {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;}
  138.       | INFIXR optdigit ops        {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;}
  139.       | INFIX  optdigit ops        {fixDefn(NON_ASS,$1,$2,$3);  sp-=3;}
  140.       ;
  141. optdigit  : NUMLIT            {$$ = gc1(checkPrec($1));}
  142.       | /* empty */            {$$ = gc0(mkInt(DEF_PREC));}
  143.       ;
  144. ops      : ops ',' op            {$$ = gc3(cons($3,$1));}
  145.       | op                {$$ = gc1(cons($1,NIL));}
  146.       ;
  147. op      : varop            {$$ = $1;}
  148.       | conop            {$$ = $1;}
  149.       | '-'                {$$ = gc1(varMinus);}
  150.       ;
  151. varop      : VAROP            {$$ = $1;}
  152.       | '`' VARID '`'        {$$ = gc3($2);}
  153.       ;
  154. conop      : CONOP            {$$ = $1;}
  155.       | '`' CONID '`'        {$$ = gc3($2);}
  156.       ;
  157.  
  158. /*- Processing definitions of primitives ----------------------------------*/
  159.  
  160. topdecl      : PRIMITIVE prims COCO type    {primDefn(intOf($1),$2,$4); sp-=4;}
  161.       ;
  162. prims      : prims ',' prim        {$$ = gc3(cons($3,$1));}
  163.       | prim            {$$ = gc1(cons($1,NIL));}
  164.       | error            {syntaxError("primitive defn");}
  165.       ;
  166. prim      : var STRINGLIT        {$$ = gc2(pair($1,$2));}
  167.       ;
  168.  
  169. /*- Class declarations: ---------------------------------------------------*/
  170.  
  171. topdecl      : TCLASS classHead classBody    {classDefn(intOf($1),$2,$3); sp-=3;}
  172.       | TINSTANCE classHead instBody{instDefn(intOf($1),$2,$3);  sp-=3;}
  173.       ;
  174. classHead : context IMPLIES typeApp1    {$$ = gc3(pair($1,$3));}
  175.       | typeApp1            {$$ = gc1(pair(NIL,$1));}
  176.       ;
  177. classBody : WHERE '{' csigdecls close    {$$ = gc4($3);}
  178.       | /* empty */            {$$ = gc0(NIL);}
  179.       ;
  180. instBody  : WHERE '{' decls close    {$$ = gc4($3);}
  181.       | /* empty */            {$$ = gc0(NIL);}
  182.       ;
  183. csigdecls : csigdecls ';' csigdecl    {$$ = gc3(cons($3,$1));}
  184.       | csigdecl            {$$ = gc1(cons($1,NIL));}
  185.       ;
  186. csigdecl  : vars COCO type        {$$ = gc3(sigdecl($2,$1,$3));}
  187.       | opExp rhs            {$$ = gc2(pair($1,$2));}
  188.       ;
  189.  
  190. /*- Value declarations: ---------------------------------------------------*/
  191.  
  192. decl      : vars COCO sigType        {$$ = gc3(sigdecl($2,$1,$3));}
  193.       | opExp rhs            {$$ = gc2(pair($1,$2));}
  194.       ;
  195. decls      : decls ';' decl        {$$ = gc3(cons($3,$1));}
  196.       | decl            {$$ = gc1(cons($1,NIL));}
  197.       ;
  198. rhs      : rhs1 wherePart        {$$ = gc2(letrec($2,$1));}
  199.       | rhs1            {$$ = $1;}
  200.       ;
  201. rhs1      : '=' exp            {$$ = gc2(pair($1,$2));}
  202.       | gdefs            {$$ = gc1(grded(rev($1)));}
  203.       ;
  204. wherePart : WHERE '{' decls close    {$$ = gc4($3);}
  205.       ;
  206. gdefs      : gdefs gdef            {$$ = gc2(cons($2,$1));}
  207.       | gdef            {$$ = gc1(cons($1,NIL));}
  208.       ;
  209. gdef      : '|' exp '=' exp        {$$ = gc4(pair($3,pair($2,$4)));}
  210.       /* Experimental, undocumented syntax for Orwell style guards     */
  211.       /* The corresponding forms for case definitions are NOT supported*/
  212.       /* because that would require a change to the original syntax for*/
  213.           /* Gofer, rather than a simple extension as is the case here.    */
  214.       /* Perhaps a slight reworking of the grammar might eliminate this*/
  215.       /* problem...                               */
  216.       | '=' exp ',' IF exp        {$$ = gc5(pair($1,pair($5,$2)));}
  217.       | '=' exp ',' exp        {$$ = gc4(pair($1,pair($4,$2)));}
  218.       ;
  219. vars      : vars ',' var        {$$ = gc3(cons($3,$1));}
  220.       | var                {$$ = gc1(cons($1,NIL));}
  221.       ;
  222. var      : varid            {$$ = $1;}
  223.       | '(' '-' ')'            {$$ = gc3(varMinus);}
  224.       ;
  225. varid      : VARID            {$$ = $1;}
  226.       | '(' VAROP ')'        {$$ = gc3($2);}
  227.       ;
  228. conid      : CONID            {$$ = $1;}
  229.       | '(' CONOP ')'        {$$ = gc3($2);}
  230.       ;
  231.  
  232. /*- Expressions: ----------------------------------------------------------*/
  233.  
  234. exp      : '\\' pats FUNARROW exp    {$$ = gc4(ap(LAMBDA,
  235.                              pair(rev($2),
  236.                                   pair($3,$4))));}
  237.       | LET '{' decls close IN exp    {$$ = gc6(letrec($3,$6));}
  238.       | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
  239.       | CASEXP exp OF '{' alts close{$$ = gc6(ap(CASE,pair($2,rev($5))));}
  240.       | opExp COCO sigType        {$$ = gc3(ap(ESIGN,pair($1,$3)));}
  241.       | opExp            {$$ = $1;}
  242.       | error            {syntaxError("expression");}
  243.       ; 
  244. pats      : pats atomic            {$$ = gc2(cons($2,$1));}
  245.       | atomic            {$$ = gc1(cons($1,NIL));}
  246.       ;
  247. opExp      : pfxExp            {$$ = $1;}
  248.       | pfxExp op pfxExp        {$$ = gc3(ap(ap($2,$1),$3));}
  249.       | opExp0            {$$ = gc1(tidyInfix($1));}
  250.       ;
  251. opExp0      : opExp0 op pfxExp        {$$ = gc3(ap(ap($2,$1),$3));}
  252.       | pfxExp op pfxExp op pfxExp    {$$ = gc5(ap(ap($4,
  253.                             ap(ap($2,singleton($1)),
  254.                                                            $3)),$5));}
  255.       ;
  256. pfxExp      : '-' appExp            {if (isInt($2))
  257.                          $$ = gc2(mkInt(-intOf($2)));
  258.                      else
  259.                          $$ = gc2(ap(varNegate,$2));
  260.                     }
  261.       | appExp            {$$ = $1;}
  262.       ;
  263. appExp      : appExp atomic        {$$ = gc2(ap($1,$2));}
  264.       | atomic            {$$ = $1;}
  265.       ;
  266. atomic      : var                {$$ = $1;}
  267.       | var '@' atomic        {$$ = gc3(ap(ASPAT,pair($1,$3)));}
  268.       | '~' atomic            {$$ = gc2(ap(LAZYPAT,$2));}
  269.       | '_'                {$$ = gc1(WILDCARD);}
  270.       | conid            {$$ = $1;}
  271.       | '(' ')'            {$$ = gc2(UNIT);}
  272.       | NUMLIT            {$$ = $1;}
  273.       | CHARLIT            {$$ = $1;}
  274.       | STRINGLIT            {$$ = $1;}
  275.       | REPEAT            {$$ = $1;}
  276.       | '(' exp ')'            {$$ = gc3($2);}
  277.       | '(' exps2 ')'        {$$ = gc3(buildTuple($2));}
  278.       | '[' list ']'        {$$ = gc3($2);}
  279.       | '(' pfxExp op ')'        {$$ = gc4(ap($3,$2));}
  280.       | '(' varop atomic ')'    {$$ = gc4(ap(ap(varFlip,$2),$3));}
  281.       | '(' conop atomic ')'    {$$ = gc4(ap(ap(varFlip,$2),$3));}
  282.       ;
  283. exps2      : exps2 ',' exp        {$$ = gc3(cons($3,$1));}
  284.       | exp ',' exp            {$$ = gc3(cons($3,cons($1,NIL)));}
  285.       ;
  286. alts      : alts ';' alt        {$$ = gc3(cons($3,$1));}
  287.       | alt                {$$ = gc1(cons($1,NIL));}
  288.       ;
  289. alt      : opExp altRhs        {$$ = gc2(pair($1,$2));}
  290.       ;
  291. altRhs      : altRhs1 wherePart        {$$ = gc2(letrec($2,$1));}
  292.       | altRhs1            {$$ = $1;}
  293.       ;
  294. altRhs1      : guardAlts            {$$ = gc1(grded(rev($1)));}
  295.       | FUNARROW exp        {$$ = gc2(pair($1,$2));}
  296.       ;
  297. guardAlts : guardAlts guardAlt        {$$ = gc2(cons($2,$1));}
  298.       | guardAlt            {$$ = gc1(cons($1,NIL));}
  299.       ;
  300. guardAlt  : '|' opExp FUNARROW exp    {$$ = gc4(pair($3,pair($2,$4)));}
  301.       ;
  302.  
  303. /*- List Expressions: -------------------------------------------------------*/
  304.  
  305. list      : /* empty */            {$$ = gc0(nameNil);}
  306.       | exp                {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
  307.       | exps2            {$$ = gc1(ap(FINLIST,rev($1)));}
  308.       | exp '|' quals        {$$ = gc3(ap(LISTCOMP,
  309.                             pair($1,rev($3))));}
  310.       | exp         UPTO exp    {$$ = gc3(ap(ap(varFromTo,$1),$3));}
  311.       | exp ',' exp UPTO        {$$ = gc4(ap(ap(varFromThen,$1),$3));}
  312.       | exp         UPTO        {$$ = gc2(ap(varFrom,$1));}
  313.       | exp ',' exp UPTO exp    {$$ = gc5(ap(ap(ap(varFromThenTo,
  314.                                                                $1),$3),$5));}
  315.       ;
  316. quals      : quals ',' qual        {$$ = gc3(cons($3,$1));}
  317.       | qual            {$$ = gc1(cons($1,NIL));}
  318.       ;
  319. qual      : exp FROM exp        {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
  320.       | exp '=' exp            {$$ = gc3(ap(QWHERE,pair($1,$3)));}
  321.       | exp                {$$ = gc1(ap(BOOLQUAL,$1));}
  322.       ;
  323.  
  324. /*- Find closing brace ----------------------------------------------------*/
  325.  
  326.                     /* deal with trailing semicolon    */
  327. close      : ';' close1            {$$ = gc2($2);}
  328.       | close1            {$$ = $1;}
  329.       ;
  330. close1      : '}'                {$$ = $1;}
  331.       | error            {yyerrok;
  332.                                          if (canUnOffside()) {
  333.                                              unOffside();
  334.                          /* insert extra token on stack*/
  335.                          push(NIL);
  336.                          pushed(0) = pushed(1);
  337.                          pushed(1) = mkInt(row);
  338.                      }
  339.                                          else
  340.                                              syntaxError("definition");
  341.                                         }
  342.       ;
  343.  
  344. /*-------------------------------------------------------------------------*/
  345.  
  346. %%
  347.  
  348. static Cell local gcShadow(n,e)        /* keep parsed fragments on stack  */
  349. Int  n;
  350. Cell e; {
  351.     /* If a look ahead token is held then the required stack transformation
  352.      * is:
  353.      *   pushed: n               1     0          1     0
  354.      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
  355.      *                                top()            top()
  356.      *
  357.      * Othwerwise, the transformation is:
  358.      *   pushed: n-1             0        0
  359.      *           x1  |  ...  |  xn  ===>  e
  360.      *                         top()     top()
  361.      */
  362.     if (yychar>=0) {
  363.     pushed(n-1) = top();
  364.         pushed(n)   = e;
  365.     }
  366.     else
  367.     pushed(n-1) = e;
  368.     sp -= (n-1);
  369.     return e;
  370. }
  371.  
  372. static Void local syntaxError(s)       /* report on syntax error           */
  373. String s; {
  374.     ERROR(row) "Syntax error in %s (unexpected %s)", s, unexpected()
  375.     EEND;
  376. }
  377.  
  378. static String local unexpected() {    /* find name for unexpected token  */
  379.     static char buffer[100];
  380.     switch (yychar) {
  381.     case 0           : return "end of input";
  382.  
  383. #define keyword(kw) sprintf(buffer,"\"%s\" keyword",kw); return buffer;
  384.     case INFIXL    : keyword("infixl");
  385.     case INFIXR    : keyword("infixr");
  386.     case INFIX     : keyword("infix");
  387.     case TINSTANCE : keyword("instance");
  388.     case TCLASS    : keyword("class");
  389.     case PRIMITIVE : keyword("primitive");
  390.     case CASEXP    : keyword("case");
  391.     case OF        : keyword("of");
  392.     case IF        : keyword("if");
  393.     case THEN      : keyword("then");
  394.     case ELSE      : keyword("else");
  395.     case WHERE     : keyword("where");
  396.     case TYPE      : keyword("type");
  397.     case DATA      : keyword("data");
  398.     case LET       : keyword("let");
  399.     case IN        : keyword("in");
  400. #undef keyword
  401.  
  402.     case FUNARROW  : return "`->'";
  403.     case '='       : return "`='";
  404.     case COCO      : return "`::'";
  405.     case '-'       : return "`-'";
  406.     case ','       : return "comma";
  407.     case '@'       : return "`@'";
  408.     case '('       : return "`('";
  409.     case ')'       : return "`)'";
  410.     case '|'       : return "`|'";
  411.     case ';'       : return "`;'";
  412.     case UPTO      : return "`..'";
  413.     case '['       : return "`['";
  414.     case ']'       : return "`]'";
  415.     case FROM      : return "`<-'";
  416.     case '\\'      : return "`\\'";
  417.     case '~'       : return "`~'";
  418.     case '`'       : return "``'";
  419.     case VAROP     :
  420.     case VARID     :
  421.     case CONOP     :
  422.     case CONID     : sprintf(buffer,"symbol \"%s\"",
  423.                  textToStr(textOf(yylval)));
  424.              return buffer;
  425.     case NUMLIT    : return "numeric literal";
  426.     case CHARLIT   : return "character literal";
  427.     case STRINGLIT : return "string literal";
  428.     case IMPLIES   : return "`=>";
  429.     default           : return "token";
  430.     }
  431. }
  432.  
  433. static Cell local checkPrec(p)         /* Check for valid precedence value */
  434. Cell p; {
  435.     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
  436.         ERROR(row) "Precedence value must be an integer in the range [%d..%d]",
  437.                    MIN_PREC, MAX_PREC
  438.         EEND;
  439.     }
  440.     return p;
  441. }
  442.  
  443. static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators      */
  444. Syntax a;
  445. Cell   line;
  446. Cell   p;
  447. List   ops; {
  448.     Int l = intOf(line);
  449.     a     = mkSyntax(a,intOf(p));
  450.     map2Proc(setSyntax,l,a,ops);
  451. }
  452.  
  453. static Void local setSyntax(line,sy,op)/* set syntax of individ. operator  */
  454. Int    line;
  455. Syntax sy;
  456. Cell   op; {
  457.     addSyntax(line,textOf(op),sy);
  458.     opDefns = cons(op,opDefns);
  459. }
  460.  
  461. static Cell local buildTuple(tup)      /* build tuple (x1,...,xn) from list*/
  462. List tup; {                            /* [xn,...,x1]                      */
  463.     Int  n = 0;
  464.     Cell t = tup;
  465.     Cell x;
  466.  
  467.     do {                               /*     .                    .       */
  468.         x      = fst(t);               /*    / \                  / \      */
  469.         fst(t) = snd(t);               /*   xn  .                .   xn    */
  470.         snd(t) = x;                    /*        .    ===>      .          */
  471.         x      = t;                    /*         .            .           */
  472.         t      = fun(x);               /*          .          .            */
  473.         n++;                           /*         / \        / \           */
  474.     } while (nonNull(t));              /*        x1  NIL   (n)  x1         */
  475.     fst(x) = mkTuple(n);
  476.     return tup;
  477. }
  478.  
  479. /* The yacc parser presented above is not sufficiently powerful to
  480.  * determine whether a tuple at the front of a sigType is part of a
  481.  * context:    e.g. (Eq a, Num a) => a -> a -> a
  482.  * or a type:  e.g.  (Tree a, Tree a) -> Tree a
  483.  *
  484.  * Rather than complicate the grammar, both are parsed as tuples of types,
  485.  * using the following checks afterwards to ensure that the correct syntax
  486.  * is used in the case of a tupled context.
  487.  */
  488.  
  489. static List local checkContext(con)    /* validate type class context       */
  490. Type con; {
  491.     if (con==UNIT)            /* allows empty context ()       */
  492.     return NIL;
  493.     else if (whatIs(getHead(con))==TUPLE) {
  494.     List qs = NIL;
  495.  
  496.     while (isAp(con)) {        /* undo work of buildTuple  :-(    */
  497.         Cell temp = fun(con);
  498.         fun(con)  = arg(con);
  499.         arg(con)  = qs;
  500.         qs          = con;
  501.         con       = temp;
  502.         checkClass(hd(qs));
  503.     }
  504.     return qs;
  505.     }
  506.     else                /* single context expression       */
  507.     return singleton(checkClass(con));
  508. }
  509.  
  510. static Cell local checkClass(c)        /* check that type expr is a class */
  511. Cell c; {                /* constrnt of the form C t1 .. tn */
  512.     Cell cn = getHead(c);
  513.  
  514.     if (!isCon(cn))
  515.     syntaxError("class expression");
  516.     else if (argCount<1) {
  517.     ERROR(row) "Class \"%s\" must have at least one argument",
  518.            textToStr(textOf(cn))
  519.     EEND;
  520.     }
  521.     return c;
  522. }
  523.  
  524. /* expressions involving a sequence of two or more infix operator symbols
  525.  * are parsed as elements of type:
  526.  *    InfixExpr ::= [Expr]
  527.  *         |  ap(ap(Operator,InfixExpr),Expr)
  528.  *
  529.  * thus x0 +1 x1 ... +n xn is parsed as: +n (....(+1 [x0] x1)....) xn
  530.  *
  531.  * Once the expression has been completely parsed, this parsed form is
  532.  * `tidied' according to the precedences and associativities declared for
  533.  * each operator symbol.
  534.  *
  535.  * The tidy process uses a `stack' of type:
  536.  *    TidyStack ::= ap(ap(Operator,TidyStack),Expr)
  537.  *         |  NIL
  538.  * when the ith layer of an InfixExpr has been transferred to the stack, the
  539.  * stack is of the form: +i (....(+n NIL xn)....) xi
  540.  *
  541.  * The tidy function is based on a simple shift-reduce parser:
  542.  *
  543.  *  tidy                :: InfixExpr -> TidyStack -> Expr
  544.  *  tidy [m]   ss        = foldl (\x f-> f x) m ss
  545.  *  tidy (m*n) []        = tidy m [(*n)]
  546.  *  tidy (m*n) ((+o):ss)
  547.  *           | amb     = error "Ambiguous"
  548.  *           | shift   = tidy m ((*n):(+o):ss)
  549.  *           | reduce  = tidy (m*(n+o)) ss
  550.  *               where sye     = syntaxOf (*)
  551.  *                 (ae,pe) = sye
  552.  *                 sys     = syntaxOf (+)
  553.  *                 (as,ps) = sys
  554.  *                 amb     = pe==ps && (ae/=as || ae==NON_ASS)
  555.  *                 shift   = pe>ps || (ps==pe && ae==LEFT_ASS)
  556.  *                 reduce  = otherwise
  557.  *
  558.  * N.B. the conditions amb, shift, reduce are NOT mutually exclusive and
  559.  * must be tested in that order.
  560.  *
  561.  * As a concession to efficiency, we lower the number of calls to syntaxOf
  562.  * by keeping track of the values of sye, sys throughout the process.  The
  563.  * value APPLIC is used to indicate that the syntax value is unknown.
  564.  */
  565.  
  566. static Cell local tidyInfix(e)         /* convert InfixExpr to Expr        */
  567. Cell e; {                              /* :: InfixExpr                     */
  568.     Cell   s   = NIL;                  /* :: TidyStack                     */
  569.     Syntax sye = APPLIC;               /* Syntax of op in e (init unknown) */
  570.     Syntax sys = APPLIC;               /* Syntax of op in s (init unknown) */
  571.     Cell   temp;
  572.  
  573.     while (nonNull(tl(e))) {
  574.         if (isNull(s)) {
  575.             s           = e;
  576.             e           = arg(fun(s));
  577.             arg(fun(s)) = NIL;
  578.             sys         = sye;
  579.             sye         = APPLIC;
  580.         }
  581.         else {
  582.             if (sye==APPLIC) {         /* calculate sye (if unknown)       */
  583.                 sye = syntaxOf(textOf(fun(fun(e))));
  584.                 if (sye==APPLIC) sye=DEF_OPSYNTAX;
  585.             }
  586.             if (sys==APPLIC) {         /* calculate sys (if unknown)       */
  587.                 sys = syntaxOf(textOf(fun(fun(s))));
  588.                 if (sys==APPLIC) sys=DEF_OPSYNTAX;
  589.             }
  590.  
  591.             if (precOf(sye)==precOf(sys) &&                      /* amb    */
  592.                    (assocOf(sye)!=assocOf(sys) || assocOf(sye)==NON_ASS)) {
  593.                 ERROR(row) "Ambiguous use of operator \"%s\" with \"%s\"",
  594.                            textToStr(textOf(fun(fun(e)))),
  595.                            textToStr(textOf(fun(fun(s))))
  596.                 EEND;
  597.             }
  598.             else if (precOf(sye)>precOf(sys) ||                  /* shift  */
  599.                        (precOf(sye)==precOf(sys) && assocOf(sye)==LEFT_ASS)) {
  600.                 temp        = arg(fun(e));
  601.                 arg(fun(e)) = s;
  602.                 s           = e;
  603.                 e           = temp;
  604.                 sys         = sye;
  605.                 sye         = APPLIC;
  606.             }
  607.             else {                                               /* reduce */
  608.                 temp        = arg(fun(s));
  609.                 arg(fun(s)) = arg(e);
  610.                 arg(e)      = s;
  611.                 s           = temp;
  612.                 sys         = APPLIC;
  613.                 /* sye unchanged */
  614.             }
  615.         }
  616.     }
  617.  
  618.     e = hd(e);
  619.     while (nonNull(s)) {
  620.         temp        = arg(fun(s));
  621.         arg(fun(s)) = e;
  622.         e           = s;
  623.         s           = temp;
  624.     }
  625.  
  626.     return e;
  627. }
  628.  
  629. /*-------------------------------------------------------------------------*/
  630.